(PROG (SEXPR IBASE)
      (SETQ IBASE (ADD1 7))
 LOOP (SETQ SEXPR (ERRSET (READ)))
      (COND ((EQ SEXPR (QUOTE $EOF$)) (ERR)))
      (COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK)))
	     (GO LOOP)))
      (PRINT (EVAL (CAR SEXPR)))
      (GO LOOP))

(BEGINBLOCK COMPILER)

(DECLARE (SPECIAL SPECVARS LOCVARS RESULTS)
	 (SPECIAL ACS PDL QUOTES SPECIALS)
	 (SPECIAL CODESIZE CONSTSIZE STARTTIME GENFUNS UNDFUNS)
	 (SPECIAL MSGCHAN MSGDEV INDEV OUTDEV)
	 (SPECIAL FUNNAME SUBFUNS LASTOUT UNDECVARS)
	 (SPECIAL TAGLIST EXIT EXITN PRSSL VGO PVR)
	 (SPECIAL NACS INUM0 VALUEAC GOTABAC FARGAC ARRAYAC SOMEAC)
	 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
	 (SPECIAL *LP *RP *SL *AM *AT *RO *COLON)
	 (SPECIAL IBASE BASE *NOPOINT)
	 (SPECIAL TRACELIST SHOWNAMES))

(BEGINBLOCK MACROS)

(DEFPROP ARGPART (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)

(DEFPROP DEINITBTAG (LAMBDA (L) (Q (DEINITSYM (Q BTAG)))) MACRO)

(DEFPROP DEINITPTAG (LAMBDA (L) (Q (DEINITSYM (Q PTAG)))) MACRO)

(DEFPROP DEINITRES (LAMBDA (L) (Q (DEINITSYM (Q RES)))) MACRO)

(DEFPROP DEINITVAR (LAMBDA (L) (Q (DEINITSYM (Q VAR)))) MACRO)

(DEFPROP DFUNC
	 (LAMBDA (L)
		 (LIST (Q DEFPROP)
		       (CAADR L)
		       (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
		       (Q EXPR)))
	 MACRO)

(DEFPROP FUNPART (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)

(DEFPROP GENFUNNAME
	 (LAMBDA (L) (Q (MAKESYM FUNNAME (GENSYM))))
	 MACRO)

(DEFPROP GENBTAG (LAMBDA (L) (Q (NEXTSYM (Q BTAG)))) MACRO)

(DEFPROP GENPTAG (LAMBDA (L) (Q (NEXTSYM (Q PTAG)))) MACRO)

(DEFPROP GENRES (LAMBDA (L) (Q (NEXTSYM (Q RES)))) MACRO)

(DEFPROP GENVAR (LAMBDA (L) (Q (NEXTSYM (Q VAR)))) MACRO)

(DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)

(DEFPROP INITBTAG (LAMBDA (L) (Q (INITSYM (Q BTAG)))) MACRO)

(DEFPROP INITPTAG (LAMBDA (L) (Q (INITSYM (Q PTAG)))) MACRO)

(DEFPROP INITRES (LAMBDA (L) (Q (INITSYM (Q RES)))) MACRO)

(DEFPROP INITVAR (LAMBDA (L) (Q (INITSYM (Q VAR)))) MACRO)

(DEFPROP LINEF (LAMBDA (L) (Q (TERPRI))) MACRO)

(DEFPROP MAPDEF
 (LAMBDA (L)
	 (LIST (Q MAPCAR)
	       (SUBST (CADR L)
		      (Q IND)
		      (Q (FUNCTION (LAMBDA (PAIR)
					   (PUTPROP (CAR PAIR)
						    (CADR PAIR)
						    (QUOTE IND))))))
	       (LIST (Q QUOTE) (CDDR L))))
 MACRO)

(DEFPROP MCONS
 (LAMBDA (L)
	 (COND ((NULL (CDDR L)) (CADR L))
	       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
 MACRO)

(DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)

(DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)

(DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)

(DEFPROP PDLDEPTH (LAMBDA (L) (Q (LENGTH PDL))) MACRO)

(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)

(DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)

(BEGINBLOCK PROPTABLE)

(DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)

(DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)

(DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)

(DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)

(DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)

(DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)

(ENDBLOCK PROPTABLE)

(ENDBLOCK MACROS)

(BEGINBLOCK TOPLEVEL)

(DFUNC (ACTONEXPR XPR)
       (PROG (ACTION)
	     (COND ((ATOM XPR) (GO FLUSH)))
	     (SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
	     (COND (ACTION ((PROPVAL ACTION) XPR) (RETURN NIL)))
	FLUSH(FLUSHEXPR XPR)
	     (RETURN NIL)))

(DFUNC (ACTONMACRO XPR)
       (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))

(DEFPROP CMP
	 (LAMBDA (L)
		 (PROG2	(PUTPROP (CAAR L)
				 (MCONS (Q LAMBDA) (CDAR L) (CDR L))
				 (Q EXPR))
			(EVAL (LIST (Q COMPILE) (CAAR L)))))
	 FEXPR)

(DEFPROP COMFILE
	 (LAMBDA (FILE)
		 (PROG (CODESIZE CONSTSIZE)
		       (PUTPROP (Q TRY) FILE (Q FILE))
		       (SETQ CODESIZE (SETQ CONSTSIZE 0))
		       (RETURN (COMPFILE FILE))))
	 FEXPR)

(DFUNC (COMPDEF DEFIN)
 (PROG (ACTION)
       (COND ((NOT (EQUAL (LENGTH DEFIN) 4))
	      (USERERR ARGNOERR-COMPDEF)))
       (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
	      ((PROPVAL ACTION) DEFIN)
	      (RETURN NIL)))
       (FLUSHEXPR DEFIN)
       (RETURN NIL)))

(DFUNC (COMPFILE INFILE OUTFILE)
       (PROG (UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
	     (CARRET)
	     (SETQ STARTTIME (TIME))
	     (SETQ CODESIZE (SETQ CONSTSIZE 0))
	     (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
	     (TELLTALE (CADR INFILE))
	     (LINEF)))

(DFUNC (COMPFUNC FUNNAME FUNEXP FUNFLAG FUNTYPE)
 (PROG (LOCVARS SPECVARS RESULTS ACS PDL QUOTES SPECIALS LASTOUT
	SPECFLAG SUBFUNS UNDECVARS)
       (COND ((GREATERP (LENGTH (CADR FUNEXP)) NACS)
	      (USERERR TOOMANYARGS-COMPFUNC)))
       (REMPROP FUNNAME (Q *UNDEF))
       (PUTPROP FUNNAME T FUNTYPE)
       (INITBTAG)
       (INITPTAG)
       (INITRES)
       (INITVAR)
       (SETQ ACS (INITACS NACS))
       (SETQ PDL NIL)
       (REMPROP (Q ARG) (Q CMP))
       (PUTPROP (Q GO) (Q ERRGO) (Q CMP))
       (PUTPROP (Q RETURN) (Q ERRRETURN) (Q CMP))
       (CARRET)
       (OUTPSOP (LIST (Q LAP) FUNNAME FUNFLAG))
       (COND ((EQ FUNTYPE (Q *LSUBR))
	      (SETQ FUNEXP (MCONS (CAR FUNEXP)
				  (LIST (CADR FUNEXP))
				  (CDDR FUNEXP)))
	      (PUTPROP (Q ARG) (Q CMPARG) (Q CMP))
	      (OUTINST (Q (JSP 3 *LCALL))))
	     ((AND (EQ FUNTYPE (Q *FSUBR)) (CDADR FUNEXP))
	      (OUTINST (Q (PUSHJ P *AMAKE)))))
       (SETQ SPECFLAG (LAMBDABIND (CADR FUNEXP)))
       (LOADCOMP (CADDR FUNEXP) (NTHAC VALUEAC))
       (UNBINDVARS NIL)
       (RESTORE NIL)
       (COND (SPECFLAG (OUTINST (Q (PUSHJ P SPECSTR)))))
       (OUTINST (Q (POPJ P)))
       (OUTINST (OUTINST NIL))
       (COND ((NOT (NULL RESULTS)) (COMPERR RESULTSLEFT-COMPFUNC)))
       (CARRET)
       (LINEF)
       (COND ((NOT (NULL UNDECVARS))
	      (PRINTMSG (CONS (Q SPECIAL) (REVERSE UNDECVARS)))))
       (DEINITBTAG)
       (DEINITPTAG)
       (DEINITRES)
       (DEINITVAR)
       (COND (SHOWNAMES (PRINTMSG FUNNAME)))
       (MAPC (FUNCTION ACTONEXPR) SUBFUNS)
       (RETURN FUNNAME)))

(DEFPROP COMPILE
 (LAMBDA (NAMES)
  (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE MSGCHAN SHOWNAMES DONE
	 PROP NAME FLAG PLIST)
	(SETQ CODESIZE (SETQ CONSTSIZE 0))
   LOOP	(COND ((NULL NAMES) (OUTC NIL T) (RETURN (REVERSE DONE))))
	(SETQ NAME (CAR NAMES))
	(COND ((NOT (ATOM NAME)) (EVAL (CONS (Q OUTPUT) NAME))
				 (OUTC T NIL)))
	(SETQ NAMES (CDR NAMES))
	(SETQ PLIST (CDR NAME))
   ILOOP(COND ((NULL PLIST) (GO LOOP)))
	(SETQ FLAG (CAR PLIST))
	(SETQ PLIST (CDR PLIST))
	(SETQ PROP (SEEKPROP FLAG (Q DEFACTION)))
	(COND ((NULL PROP) (GO ELOOP)))
	(SETQ DONE (CONS (CONS NAME FLAG) DONE))
	((PROPVAL PROP) (LIST (Q DEFPROP) NAME (CAR PLIST) FLAG))
   ELOOP(SETQ PLIST (CDR PLIST))
	(GO ILOOP)))
 FEXPR)

(DEFPROP COMPL
 (LAMBDA (FILES)
  (PROG (MSGCHAN)
	(COND ((NOT (NULL MSGDEV))
	       (SETQ MSGCHAN (EVAL (MCONS (Q OUTPUT)
					  (GENSYM)
					  MSGDEV)))))
   LOOP	(COND ((NULL FILES) (OUTC MSGCHAN NIL)
			    (OUTC NIL T)
			    (RETURN NIL)))
	(COND ((DEVP (CAR FILES)) (SETQ INDEV (CAR FILES))
				  (GO ELOOP)))
	(COMPFILE (LIST INDEV (CAR FILES))
		  (LIST	OUTDEV
			(CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
				    (T (CAAR FILES)))
			      (Q LAP))))
   ELOOP(SETQ FILES (CDR FILES))
	(GO LOOP)))
 FEXPR)

(DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))

(DFUNC (DEFEXPR DEF)
       (PROG (NAME EXP)
	     (SETQ NAME (CADR DEF))
	     (SETQ EXP (CADDR DEF))
	     (COND ((ATOM EXP) (FLUSHEXPR DEF))
		   ((NOT (EQ (CAR EXP) (Q LAMBDA)))
		    (USERERR NONLAMDA-DEFEXPR))
		   ((AND (CADR EXP) (ATOM (CADR EXP)))
		    (COMPFUNC NAME EXP (Q LSUBR) (Q *LSUBR)))
		   (T (COMPFUNC NAME EXP (Q SUBR) (Q *SUBR))))))

(DFUNC (DEFFEXPR DEF)
       (COMPFUNC (CADR DEF) (CADDR DEF) (Q FSUBR) (Q *FSUBR)))

(DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))

(DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))

(DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))

(DFUNC (DODE XPR)
       (DEFEXPR	(LIST (Q DEFPROP)
		      (CADR XPR)
		      (LIST (Q LAMBDA) (CADDR XPR) (CADDDR XPR)))))

(DFUNC (DODECLARE XPR) (MAPC (FUNCTION EVAL) (CDR XPR)))

(DFUNC (DODF XPR)
       (DEFFEXPR (LIST (Q DEFPROP)
		       (CADR XPR)
		       (LIST (Q LAMBDA) (CADDR XPR) (CADDDR XPR)))))

(DFUNC (DOFILE DOREADS INFILE OUTFILE)
       (PROGN (INC (EVAL (MCONS (Q INPUT) (GENSYM) INFILE)) NIL)
	      (OUTC (EVAL (MCONS (Q OUTPUT) (GENSYM) OUTFILE)) NIL)
	      (DOREADS)
	      (OUTC NIL T)
	      (INC NIL T)))

(DFUNC (FLUSHEXPR EXPR)
       (PROGN (CARRET) (PRINS EXPR) (CARRET) (LINEF)))

(DFUNC (FLUSHLAP LC) (PRINTLAP (READLAP LC)))

(DFUNC (PRINTMSG MESSAGE)
       (PROG (CHAN)
	     (SETQ CHAN (OUTC MSGCHAN NIL))
	     (PRINT MESSAGE)
	     (LINEF)
	     (OUTC CHAN NIL)))

(DFUNC (READLOOP ACTFUNC)
       (PROG (EXPR)
	LOOP (SETQ EXPR (ERRSET (READ)))
	     (COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
	     (ACTFUNC (CAR EXPR))
	     (GO LOOP)))

(DEFPROP SPECIAL (LAMBDA (X) (MAPCAR (FUNCTION DECSPECIAL) X)) FEXPR)

(DFUNC (TELLTALE FILENAME)
 (PROG (CHAN)
       (SETQ CHAN (OUTC MSGCHAN NIL))
       (LINEF)
       (LINEF)
       (PRINL (LIST FILENAME (Q COMPILED)))
       (PRINL (LIST CODESIZE (Q WORDS)))
       (PRINL (LIST CONSTSIZE (Q CONSTANTS)))
       (PRINL (LIST (QUOTIENT (DIFFERENCE (TIME) STARTTIME) 1750)
		    (Q SECONDS)))
       (LINEF)
       (LINEF)
       (PRINL (Q (UNDEFINED FUNCTIONS)))
       (LINEF)
       (MAPC (FUNCTION (LAMBDA (X)
			(COND ((GET X (Q *UNDEF)) (PRINS X)))))
	     UNDFUNS)
       (LINEF)
       (LINEF)
       (PRINL (Q (GENERATED FUNCTIONS)))
       (LINEF)
       (PRINL GENFUNS)
       (LINEF)
       (LINEF)
       (OUTC CHAN NIL)))

(DEFPROP UNSPECIAL
	 (LAMBDA (X) (MAPCAR (FUNCTION DECUNSPECIAL) X))
	 FEXPR)

(MAPDEF COMPEFFECT (COMPACTION DOACT) (MACRO ACTONMACRO))

(MAPDEF COMPACTION
	 (DE DODE) (DECLARE DODECLARE) (DEFPROP COMPDEF) (DF DODF)
	 (DM EVAL) (LAP FLUSHLAP) (SPECIAL EVAL) (UNSPECIAL EVAL))

(MAPDEF DEFACTION
	 (EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO EVAL) (SPECIAL EVAL)
	 (DEFACTION EVAL) (*EXPR DO*EXPR) (*FEXPR DO*FEXPR))

(SETQ MSGDEV NIL)

(SETQ OUTDEV (SETQ INDEV (QUOTE DSK:)))

(ENDBLOCK TOPLEVEL)

(BEGINBLOCK COMPILE)

(BEGINBLOCK CONTEXTS)

(DFUNC (COMPEXPR XPR VALAC)
       (COMPFORM XPR (COND ((NULL VALAC) (FREEAC)) (T VALAC)) NIL))

(DFUNC (COMPFORM XPR VALAC TEST)
 (PROG (TEM)
       (COND ((ATOM XPR) (GO ATOM)))
       (COND ((ATOM (CAR XPR)) (GO ATOMC)))
       (COND ((EQ (CAAR XPR) (Q LAMBDA))
	      (RETURN (CMPLAM XPR VALAC TEST))))
       (COND ((EQ (CAAR XPR) (Q LABEL))
	      (RETURN (CMPLABEL XPR VALAC TEST))))
       (RETURN (CALLFUNARGS XPR VALAC TEST))
  ATOM (COND ((CONSTANTP XPR)
	      (RETURN (COMPFORM (LIST (Q QUOTE) XPR) VALAC TEST))))
       (SETQ XPR (GETVAR XPR))
       (SETQ TEM (GENRES))
       (PUTPROP TEM XPR (Q ORIGIN))
       (COND (VALAC (SETQ RESULTS (CONS TEM RESULTS))))
       (PUTIN (LIST TEM) (LOC XPR))
       (RETURN (TESTJUMP TEM TEST))
  ATOMC(COND ((CONSTANTP (CAR XPR)) (USERERR CONSTFUN-COMPFORM)))
       (COND ((SETQ TEM (GETGET (CAR XPR) (Q FTYPE)))
	      (RETURN ((PROPVAL TEM) XPR VALAC TEST))))
       (RETURN (CMPELSE XPR VALAC TEST))))

(DFUNC (COMPSTAT XPR) (COMPFORM XPR NIL NIL))

(DFUNC (COMPPRED XPR TEST) (COMPFORM XPR NIL TEST))

(ENDBLOCK CONTEXTS)

(BEGINBLOCK FUNCTIONCLASSES)

(DFUNC (CALLBOOL XPR VALAC TEST)
       (PROG (TAG)
	     (SAVEACS)
	     (COND ((NOT (NULL TEST)) (GO EASY)))
	     (PUTPROP (SETQ TAG (GENBTAG)) (TOPCOPY PDL) (Q LEVEL))
	     (SETQ TEST (CONS T TAG))
	EASY ((GETPROP (FUNPART XPR) (Q BOOL)) XPR VALAC TEST)
	     (RETURN (BOOLVALUE XPR VALAC TAG))))

(DFUNC (CALLCARCDR XPR VALAC TEST)
 (PROG (TEM)
       (COND ((NOT (EQ (LENGTH XPR) 2))
	      (USERERR FEWMANY-CALLCARCDR)))
       (COND ((AND (NULL VALAC) (NULL TEST))
	      (RETURN (COMPSTAT (CADR XPR)))))
       (PUTPROP	(SETQ TEM (GENRES))
		(MCONS TEM (CAR XPR) (COMPEXPR (CADR XPR) VALAC))
		(Q CHAIN))
       (RETURN (TESTJUMP TEM TEST))))

(DFUNC (CALLCMP XPR VALAC TEST)
 (TESTJUMP ((GETPROP (FUNPART XPR) (Q CMP)) XPR VALAC TEST) TEST))

(DFUNC (CALLCOMMU XPR VALAC TEST)
       (PROG (FUN ARGS TEM)
	     (SETQ FUN (FUNPART XPR))
	     (SETQ ARGS (COMPARGS (ARGPART XPR)))
	     (COND ((AND (SETQ TEM (SEEKPROP FUN (Q COMMU)))
			 (INREG (CAR ARGS) (NTHAC VALUEAC)))
		    (SETQ ARGS (REVERSE ARGS))
		    (SETQ FUN (PROPVAL TEM))))
	     (LOADARGS ARGS)
	     (PROTECTACS (SIDEEFFECTS FUN))
	     (PROTECTSPECIALS (SIDEEFFECTS FUN))
	     (CLEARACS)
	     (SETQ TEM (MARKVAL XPR (NTHAC VALUEAC) VALAC))
	     (OUTCALL (LENGTH ARGS) FUN)
	     (RETURN (TESTJUMP TEM TEST))))

(DFUNC (CALLFSUBR XPR VALAC TEST)
       (PROG (TEM)
	     (LOADAC (LIST (Q QUOTE) (ARGPART XPR)) (NTHAC FARGAC))
	     (PROTECTACS (SIDEEFFECTS (FUNPART XPR)))
	     (PROTECTSPECIALS (SIDEEFFECTS (FUNPART XPR)))
	     (CLEARACS)
	     (SETQ TEM (MARKVAL XPR (NTHAC VALUEAC) VALAC))
	     (OUTCALL 17 (CAR XPR))
	     (RETURN (TESTJUMP TEM TEST))))

(DFUNC (CALLFUNARGS XPR VALAC TEST)
       (PROG (ARGS FUN TEM)
	     (SETQ ARGS (COMPARGS (ARGPART XPR)))
	     (SETQ FUN (COMPEXPR (FUNPART XPR) VALAC))
	     (LOADARGS ARGS)
	     (CLEARSPECIALS)
	     (CLEARACS)
	     (DEVALUE FUN)
	     (SETQ TEM (MARKVAL XPR (NTHAC VALUEAC) VALAC))
	     (OUTCALLF (LENGTH ARGS) (ADDR (LOC FUN)))
	     (RETURN (TESTJUMP TEM TEST))))

(DFUNC (CALLINMACRO XPR VALAC TEST)
 (COMPFORM ((GETPROP (FUNPART XPR) (Q INMACRO)) XPR) VALAC TEST))

(DFUNC (CALLLSUBR XPR VALAC TEST)
 (PROG (ARGS NARGS HOME INST RETTAG TEM)
       (SETQ ARGS (ARGPART XPR))
       (SETQ NARGS (LENGTH ARGS))
       (CLEARSPECIALS)
       (SAVEACS)
       (PUSHSLOT)
       (WRITELOCK (TOPPDL))
       (READLOCK (TOPPDL))
       (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (GENBTAG)) 0 0))
  LOOP (COND ((NULL ARGS) (GO CALL)))
       (SETQ HOME (TOPCOPY PDL))
       (SETQ INST (COMPEXPR (CAR ARGS) VALAC))
       (RESTORE HOME)
       (SETQ TEM (LOC INST))
       (PUSHREG TEM)
       (WRITELOCK (TOPPDL))
       (READLOCK (TOPPDL))
       (DEVALUE INST)
       (SETQ ARGS (CDR ARGS))
       (GO LOOP)
  CALL (SETQ TEM (PDLDEPTH))
       (SAVEACS)
       (COND ((NOT (EQ (PDLDEPTH) TEM)) (COMPERR LONGPDL-LSUBRCALL)))
       (OUTINST (LIST (Q MOVNI) 6 NARGS))
  LLOOP(POPSLOT)
       (COND ((ZEROP NARGS) (GO CALL1)))
       (SETQ NARGS (SUB1 NARGS))
       (GO LLOOP)
  CALL1(CLEARSPECIALS)
       (CLEARACS)
       (SETQ TEM (MARKVAL XPR (NTHAC VALUEAC) VALAC))
       (OUTJCALL 16 (CAR XPR))
       (OUTTAG RETTAG)
       (RETURN (TESTJUMP TEM TEST))))

(DFUNC (CALLMACRO XPR VALAC TEST)
       (COMPFORM ((GETPROP (CAR XPR) (Q MACRO)) XPR) VALAC TEST))

(DFUNC (CALLSUBR XPR VALAC TEST)
       (PROG (ARGS TEM)
	     (SETQ ARGS (COMPARGS (CDR XPR)))
	     (LOADARGS ARGS)
	     (PROTECTACS (SIDEEFFECTS (FUNPART XPR)))
	     (PROTECTSPECIALS (SIDEEFFECTS (FUNPART XPR)))
	     (WRITEUNLOCKACS (LENGTH ARGS))
	     (CLEARACS)
	     (SETQ TEM (MARKVAL XPR (NTHAC VALUEAC) VALAC))
	     (OUTCALL (LENGTH ARGS) (CAR XPR))
	     (RETURN (TESTJUMP TEM TEST))))

(ENDBLOCK FUNCTIONCLASSES)

(BEGINBLOCK BOOLEAN)

(DFUNC (BOOLAND XPR VALAC TEST)
 (PROG (ARGS TAG)
       (SETQ ARGS (ARGPART XPR))
       (PUTPROP (SETQ TAG (GENBTAG)) (TOPCOPY PDL) (Q LEVEL))
  LOOP (COND ((NULL ARGS) (GO END)))
       (COMPPRED (CAR ARGS)
		 (CONS NIL (COND ((CAR TEST) TAG) (T (CDR TEST)))))
       (SETQ ARGS (CDR ARGS))
       (GO LOOP)
  END  (COND ((CAR TEST) (OUTJRST (CDR TEST))))
       (OUTENDTAG TAG)))

(DFUNC (BOOLEQ XPR VALAC TEST)
 (PROG (ARG1 ARG2 ARG1LOC ARG2LOC AC MEM TAG F ARGS)
       (SETQ ARGS (ARGPART XPR))
       (SETQ F (CAR TEST))
       (SETQ TAG (CDR TEST))
       (COND ((NOT (EQ (LENGTH ARGS) 2)) (USERERR ARGNOERR-BOOLEQ)))
       (SETQ ARG1 (COMPEXPR (CAR ARGS) (FREEAC)))
       (SETQ ARG2 (COMPEXPR (CADR ARGS) (FREEAC)))
       (SETQ ARG2LOC (ILOC1 ARG2 NIL))
       (SETQ ARG1LOC (ILOC1 ARG1 NIL))
       (COND ((ISAC ARG1LOC) (SETQ AC ARG1LOC)
			     (DEVALUE ARG1)
			     (COND ((ISAC ARG2LOC) (DEVALUE ARG2)))
			     (RST TAG)
			     (SETQ MEM (LOC ARG2))
			     (GO A))
	     ((ISAC ARG2LOC) (DEVALUE ARG2)
			     (SETQ AC ARG2LOC)
			     (RST TAG)
			     (SETQ MEM (LOC ARG1))
			     (GO A)))
       (LOADAC ARG1 (SETQ AC (FREEAC)))
       (RST TAG)
       (SETQ MEM (LOC ARG2))
       (GO B)
  A    (DEVALUE ARG1)
  B    (DEVALUE ARG2)
       (SAVEACS)
       (OUT1 (COND (F (Q CAMN)) (T (Q CAME))) AC MEM)
       (OUTJRST TAG)))

(DFUNC (BOOLNULL XPR VALAC TEST)
       (COMPPRED (CADR XPR) (CONS (NOT (CAR TEST)) (CDR TEST))))

(DFUNC (BOOLOR XPR VALAC TEST)
 (PROG (ARGS TAG)
       (SETQ ARGS (ARGPART XPR))
       (PUTPROP (SETQ TAG (GENBTAG)) (TOPCOPY PDL) (Q LEVEL))
  LOOP (COND ((NULL ARGS) (GO END)))
       (COMPPRED (CAR ARGS)
		 (CONS T (COND ((CAR TEST) (CDR TEST)) (T TAG))))
       (SETQ ARGS (CDR ARGS))
       (GO LOOP)
  END  (COND ((NOT (CAR TEST)) (OUTJRST (CDR TEST))))
       (OUTENDTAG TAG)))

(DFUNC (BOOLVALUE XPR VALAC TAG)
       (COND ((NULL VALAC) (OUTENDTAG TAG))
	     (T	(OUTTDZA VALAC)
		(OUTENDTAG TAG)
		(LOADAC (Q (QUOTE T)) VALAC)
		(MARKVAL XPR VALAC VALAC))))

(ENDBLOCK BOOLEAN)

(BEGINBLOCK SPECIALFUNCTIONS)

(DFUNC (CMP*EVAL XPR VALAC TEST)
 (PROG (TEM ARG FUN)
       (SETQ ARG (CADR XPR))
       (COND ((NOT (EQ (CAR ARG) (Q CONS))) (GO NOBUM)))
       (SETQ FUN (CADR ARG))
  MACRO(COND ((SETQ TEM (GETL (CAR FUN) (Q (MACRO INMACRO))))
	      (SETQ FUN ((CADR TEM) FUN))
	      (GO MACRO)))
       (COND ((NOT (EQ (CAR FUN) (Q QUOTE))) (GO NOBUM)))
       (SETQ TEM (CADR FUN))
       (COND ((NOT (GETL TEM (Q (FEXPR FSUBR *FSUBR)))) (GO NOBUM)))
       (LOADCOMP (CADDR ARG) (NTHAC FARGAC))
       (PROTECTACS (SIDEEFFECTS TEM))
       (PROTECTSPECIALS (SIDEEFFECTS FUN))
       (OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM)))
       (RETURN (MARKVAL XPR (NTHAC VALUEAC) VALAC))
  NOBUM(RETURN (CALLSUBR XPR VALAC TEST))))

(DFUNC (CMPARG XPR VALAC TEST)
       (PROG (ARG)
	     (SETQ ARG (COMPEXPR (CADR XPR) VALAC))
	     (COND ((EQ (CAR ARG) (Q QUOTE))
		    (CPUSH VALAC)
		    (OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
		    (DEVALUE ARG)
		    (OUTINST (LIST (Q HRRZ) VALAC (CADR ARG) VALAC))
		    (RETURN (MARKVAL XPR VALAC VALAC))))
	     (LOADAC ARG VALAC)
	     (OUT1 (Q ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
	     (OUTINST (LIST (Q HRRZ) VALAC (MINUS INUM0) VALAC))
	     (RETURN (MARKVAL XPR VALAC VALAC))))

(DFUNC (CMPCOND XPR VALAC TEST)
 (PROG (CONDEND PAIREND SAVE IRSSL PAIR ARGS)
       (CLEARRESULTS)
       (CLEARSPECIALS)
       (SAVEACS)
       (SETQ IRSSL (TOPCOPY PDL))
       (PUTPROP (SETQ CONDEND (GENBTAG)) IRSSL (Q LEVEL))
       (SETQ ARGS (ARGPART XPR))
  LOOP (COND ((NULL ARGS) (LOADAC (Q (QUOTE NIL)) VALAC)
			  (OUTENDTAG CONDEND)
			  (RETURN (MARKVAL XPR VALAC VALAC))))
       (SETQ PAIR (CAR ARGS))
       (PUTPROP (SETQ PAIREND (GENBTAG)) IRSSL (Q LEVEL))
       (LOADAC (COMPFORM (CAR PAIR)
			 (COND ((NULL (CDR PAIR)) VALAC) (T NIL))
			 (CONS NIL PAIREND))
	       (COND ((NULL (CDR PAIR)) VALAC) (T NIL)))
       (SETQ SAVE (LIST ACS PDL SPECIALS QUOTES))
       (SETQ ACS (TOPCOPY ACS))
       (SETQ PDL (TOPCOPY PDL))
       (SETQ SPECIALS (TOPCOPY SPECIALS))
       (SETQ QUOTES (TOPCOPY QUOTES))
       (COND ((NOT (NULL VALAC))
	      (SETQ VALAC (NTHAC (CADR (REGNAME VALAC))))))
       (LOADAC (CMPPROGN PAIR VALAC TEST) VALAC)
       (RESTORE (CADR SAVE))
       (SETQ ACS (CAR SAVE))
       (COND ((NOT (NULL VALAC))
	      (SETQ VALAC (NTHAC (CADR (REGNAME VALAC))))))
       (SETQ PDL (CADR SAVE))
       (SETQ SPECIALS (CADDR SAVE))
       (SETQ QUOTES (CADDDR SAVE))
       (OUTJRST CONDEND)
       (OUTENDTAG PAIREND)
  ELOOP(SETQ ARGS (CDR ARGS))
       (GO LOOP)))

(DFUNC (CMPCONS XPR VALAC TEST)
       (COND ((NOT (EQ (LENGTH XPR) 3)) (USERERR ARGNOERR-CMPCONS))
	     ((NULL (CADDR XPR))
	      (CALLSUBR (LIST (Q NCONS) (CADR XPR)) VALAC TEST))
	     (T (CALLCOMMU XPR VALAC TEST))))

(DFUNC (CMPELSE XPR VALAC TEST)
       (PROGN (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
	      (PUTPROP (CAR XPR) T (Q *UNDEF))
	      (CALLSUBR XPR VALAC TEST)))

(DFUNC (CMPERRSET XPR VALAC TEST)
       (COND ((ATOM (CADR XPR)) (CALLFSUBR XPR VALAC TEST))
	     (T	(CALLFSUBR (MCONS (CAR XPR)
				  (LIST	(GENFUN	(LIST (Q LAMBDA)
						      NIL
						      (CADR XPR))))
				  (CDDR XPR))
			   VALAC
			   TEST))))

(DFUNC (CMPEVAL XPR VALAC TEST)
       (COND ((NULL (CDDR XPR))
	      (COMPFORM (CONS (Q *EVAL) (ARGPART XPR)) VALAC TEST))
	     (T (CALLFSUBR XPR VALAC TEST))))

(DFUNC (CMPFUNCTION XPR VALAC TEST)
       (PROG (FUN)
	     (SETQ FUN (GENFUN (CADR XPR)))
	     (COND ((NOT (EQ (CAR XPR) (Q FUNCTION))) (GO *FUN)))
	     (RETURN (COMPFORM (LIST (Q QUOTE) FUN) VALAC TEST))
	*FUN (CALLFSUBR (LIST (FUNPART XPR) FUN) VALAC TEST)))

(DFUNC (CMPGO XPR VALAC TEST)
       (PROG (TAG)
	     (COND ((OR VALAC TEST) (USERERR NOGO-CMPGO)))
	     (SETQ TAG (CADR XPR))
	     (SAVEACS)
	     (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
		   (T (LOADAC (COMPEXPR TAG VALAC) (NTHAC GOTABAC))
		      (OUTJRST VGO)))
	     (RETURN NIL)))

(DFUNC (CMPPROG XPR VALAC TEST)
 (PROG (STATS TAGLIST EXIT EXITN PVR PRSSL VGO PSFLG SAVELOCVARS)
       (SETQ SAVELOCVARS LOCVARS)
       (PUTPROP (Q GO) (Q CMPGO) (Q CMP))
       (PUTPROP (Q RETURN) (Q CMPRETURN) (Q CMP))
       (SETQ PSFLG (PROGBIND (CADR XPR)))
       (CLEARRESULTS)
       (CLEARSPECIALS)
       (SAVEACS)
       (SETQ PRSSL (TOPCOPY PDL))
       (SETQ PVR (REGNAME VALAC))
       (SETQ EXIT (GENPTAG))
       (SETQ EXITN (GENPTAG))
       (SETQ VGO (GENPTAG))
       (SETQ TAGLIST (LIST (CONS NIL EXIT)
			   (CONS NIL EXITN)
			   (CONS NIL VGO)))
       (SETQ STATS (CDDR XPR))
  LOOP (COND ((NULL STATS) (GO EXITN)))
       (COND ((TAGP (CAR STATS)) (PROGTAG (CAR STATS)))
	     (T (COMPSTAT (CAR STATS))))
       (SETQ STATS (CDR STATS))
       (GO LOOP)
  EXITN(OUTENDTAG EXITN)
       (LOADAC (Q (QUOTE NIL)) (NTHAC (CADR PVR)))
  EXIT (OUTENDTAG EXIT)
       (OUTGOTAB VGO (CDDDR (REVERSE TAGLIST)))
       (COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
       (UNBINDVARS SAVELOCVARS)
       (RETURN (MARKVAL XPR (NTHAC (CADR PVR)) VALAC))))

(DFUNC (CMPPROG2 XPR VALAC TEST)
 (PROG (ARG2)
       (COND ((LESSP (LENGTH XPR) 3) (USERERR TOFEWARGS-CMPPROG2)))
       (COMPSTAT (CADR XPR))
       (SETQ ARG2 (COMPFORM (CADDR XPR) VALAC TEST))
       (MAPC (FUNCTION COMPSTAT) (CDDDR XPR))
       (RETURN ARG2)))

(DFUNC (CMPPROGN XPR VALAC TEST)
       (PROG (ARGS)
	     (COND ((NULL (SETQ ARGS (CDR XPR))) (RETURN NIL)))
	LOOP (COND ((NULL (CDR ARGS))
		    (RETURN (COMPFORM (CAR ARGS) VALAC TEST))))
	     (COMPSTAT (CAR ARGS))
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))

(DFUNC (CMPQUOTE XPR VALAC TEST) XPR)

(DFUNC (CMPRETURN XPR VALAC TEST)
 (PROG (VAL)
       (COND ((OR VALAC TEST) (USERERR NORETURN-CMPRETURN)))
       (COND ((NULL (CDR XPR)) (SETQ VAL NIL))
	     (T (SETQ VAL (CADR XPR))))
       (SAVEACS)
       (COND ((NULL VAL) (OUTJRST EXITN))
	     (T	(LOADAC (COMPEXPR VAL VALAC) (NTHAC (CADR PVR)))
		(OUTJRST EXIT)))
       (RETURN NIL)))

(DFUNC (CMPRPLAC XPR VALAC TEST)
       (PROG (ARG1 ARG2)
	     (SETQ ARG1 (COMPEXPR (CADR XPR) (FREEAC)))
	     (SETQ ARG2 (COMPEXPR (CADDR XPR) (FREEAC)))
	     (ILOC1 ARG1 VALAC)
	     (LOC ARG2)
	     (COND ((EQUAL ARG2 (Q (QUOTE NIL)))
		    (OUT1 (CADR	(ASSOC (CAR XPR)
				       (Q ((RPLACA HRRZS@)
					   (RPLACD HLLZS@)))))
			  0
			  (LOC ARG1)))
		   (T (OUT1 (CADR (ASSOC (CAR XPR)
					 (Q ((RPLACA HRLM@)
					     (RPLACD HRRM@)))))
			    (PUTINAC ARG2 (FREEAC))
			    (LOC ARG1))))
	     (DEVALUE ARG1)
	     (DEVALUE ARG2)
	     (RETURN ARG1)))

(DFUNC (CMPSETARG XPR VALAC TEST)
       (PROG (ARG1 ACC INDEX)
	     (SETQ ACC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
	     (COND ((NOT (NEEDREG ACC)) (WRITELOCK ACC)))
	     (SETQ INDEX (FREEAC))
	     (SETQ ARG1 (COMPEXPR (CADR XPR) INDEX))
	     (WRITEUNLOCK ACC)
	     (LOADCOMP (CADDR XPR) ACC)
	     (COND ((EQ (CAR ARG1) (Q QUOTE)) (GO QUOTE)))
	     (LOADAC ARG1 INDEX)
	     (OUT1 (Q ADD) INDEX (MINUS (ADD1 (PDLDEPTH))))
	     (OUTINST (LIST (Q HRRM) ACC (MINUS INUM0) INDEX))
	     (GO RETN)
	QUOTE(OUTMOVE INDEX (MINUS (ADD1 (PDLDEPTH))))
	     (OUTINST (LIST (Q HRRM) ACC (CADR ARG1) INDEX))
	RETN (SETREG INDEX NIL)
	     (RETURN (MARKVAL XPR ACC VALAC))))

(DFUNC (CMPSETQ XPR VALAC TEST)
       (PROG (VAR VAL LOC AC)
	     (SETQ VAR (GETVAR (CADR XPR)))
	     (SETQ VAL (COMPEXPR (CADDR XPR) VALAC))
	     (SETQ AC (PUTINAC VAL VALAC))
	     (SETQ LOC (LOC VAR))
	     (EXPUNGE VAR)
	     (PUTIN (LIST VAR) AC)
	     (MOVEFROMAC AC LOC)
	     (RETURN VAL)))

(DFUNC (CMPSTORE XPR VALAC TEST)
       (PROG (TEM)
	     (LOC (SETQ TEM (COMPEXPR (CADDR XPR) VALAC)))
	     (COMPSTAT (CADR XPR))
	     (LOADAC TEM (NTHAC ARRAYAC))
	     (OUTINST (Q (PUSHJ P NSTR)))
	     (RETURN TEM)))

(ENDBLOCK SPECIALFUNCTIONS)

(BEGINBLOCK LAMBDALABEL)

(DFUNC (CMPLABEL XPR VALAC TEST)
       (PROG2 (SETQ SUBFUNS (CONS (LIST	(Q DEFPROP)
					(CADAR XPR)
					(CADDAR XPR)
					(Q EXPR))
				  SUBFUNS))
	      (COMPFORM (CONS (CADAR XPR) (CDDR XPR)) VALAC TEST)))

(DFUNC (CMPLAM XPR VALAC TEST)
 (PROG (LAMXPR LAMARGS SF LAMVARS TL ACL TEM SAVELOCVARS)
       (SETQ SAVELOCVARS LOCVARS)
       (SETQ LAMXPR (CAR XPR))
       (SETQ LAMARGS (REVERSE (COMPARGS (CDR XPR))))
       (SETQ LAMVARS (CADR LAMXPR))
  A    (COND ((NULL LAMVARS) (GO B)))
       (SETQ TL (ILOC1 (CAR LAMARGS) (FREEAC)))
       (DEVALUE (CAR LAMARGS))
       (COND ((SPECIALP (CAR LAMVARS))
	      (SETQ SF T)
	      (COND ((NOT (ISAC TL))
		     (LOADAC (CAR LAMARGS) (SETQ TL (FREEAC))))))
	     ((OR (NOT (NUMBERP TL)) (DVP (SETQ TEM (REGCONT TL))))
	      (PUSHSLOT TEM)
	      (OUTPUSH TL)
	      (SETQ TL 0)))
       (SETQ TEM (BINDVAR (CAR LAMVARS)))
       (SETREG TL (CONS TEM (Q TAKEN)))
       (SETQ ACL (CONS TL ACL))
       (SETQ LAMARGS (CDR LAMARGS))
       (SETQ LAMVARS (CDR LAMVARS))
       (GO A)
  B    (COND (SF (OUTINST (Q (JSP 6 SPECBIND)))))
       (SETQ LAMVARS (CADR LAMXPR))
       (SETQ ACL (REVERSE ACL))
  C    (COND ((NULL LAMVARS) (GO D))
	     ((SPECIALP (CAR LAMVARS))
	      (CMPLAM1 LAMVARS ACS)
	      (CMPLAM1 LAMVARS PDL)
	      (OUTINST (LIST 0
			     (CAR ACL)
			     (LIST (Q SPECIAL) (CAR LAMVARS))))))
       (RPLACD (REGCONT (CAR ACL)) NIL)
       (SETQ LAMVARS (CDR LAMVARS))
       (SETQ ACL (CDR ACL))
       (GO C)
  D    (SETQ TEM (COMPEXPR (CADDR LAMXPR) VALAC))
       (COND (SF (OUTINST (Q (PUSHJ P SPECSTR)))))
       (UNBINDVARS SAVELOCVARS)
       (RETURN TEM)))

(DFUNC (CMPLAM1 X Y)
       (PROG NIL
	A    (COND ((NULL Y) (RETURN NIL))
		   ((NULL (CAR Y)))
		   ((AND (EQ (CAAR Y) (CAR X)) (NULL (CDAR Y)))
		    (RPLACA Y NIL)))
	     (SETQ Y (CDR Y))
	     (GO A)))

(ENDBLOCK LAMBDALABEL)

(BEGINBLOCK PROG)

(DFUNC (EQUIVTAG PTAG)
 (PROG (LTAG)
       (COND ((SETQ LTAG (ASSOC PTAG TAGLIST)) (RETURN (CDR LTAG))))
       (SETQ TAGLIST (CONS (CONS PTAG (SETQ LTAG (GENPTAG)))
			   TAGLIST))
       (RETURN LTAG)))

(DFUNC (ERRGO XPR VALAC TEST) (USERERR GO NOT IN PROG))

(DFUNC (ERRRETURN XPR VALAC TEST) (USERERR RETURN NOT IN PROG))

(DFUNC (OUTGOTAB START TAGS)
 (PROG (ETAG)
       (COND ((NOT (GET START) (Q USED)) (RETURN NIL)))
       (PUTPROP (SETQ ETAG (GENPTAG)) (TOPCOPY PDL) (Q LEVEL))
       (OUTJRST ETAG)
       (OUTTAG START)
  LOOP (COND ((NULL TAGS) (OUTINST (Q (PUSHJ P *UDT)))
			  (OUTTAG ETAG)
			  (RETURN NIL)))
       (OUTINST (LIST (Q CAIN) GOTABAC (LIST (Q QUOTE) (CAAR TAGS))))
       (OUTJRST (CDAR TAGS))
       (SETQ TAGS (CDR TAGS))
       (GO LOOP)))

(ENDBLOCK PROG)

(DFUNC (BINDVAR VAR)
       (PROG (TEM)
	     (COND ((NOT (VARIABLEP VAR)) (USERERR NOTVAR-BINDVAR)))
	     (COND ((SPECIALP VAR) (MAKESPECIAL VAR) (RETURN VAR)))
	     (SETQ TEM VAR)
	     (COND ((ASSOC VAR LOCVARS) (SETQ VAR (GENVAR))))
	     (SETQ LOCVARS (CONS (CONS TEM VAR) LOCVARS))
	     (COND ((NOT (GETGET VAR (Q FTYPE)))
		    (PUTPROP VAR T (Q FUNVAR))))
	     (RETURN VAR)))

(DFUNC (COMPARGS ARGS)
       (PROG (AC ANS)
	     (SETQ AC (FIRSTAC))
	LOOP (COND ((NULL ARGS) (RETURN ANS)))
	     (SETQ ANS (CONS (CONS (COMPEXPR (CAR ARGS) AC) AC) ANS))
	     (SETQ AC (NEXTAC AC))
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))

(DFUNC (CPUSH REG)
       (PROG (ACC HOLD PREG)
	     (COND ((NOT (NEEDREG REG)) (RETURN NIL)))
	START(SETQ PREG (TOPPDL))
	LOOP (COND ((BOTTOMPDL PREG) (GO NONE)))
	     (SETQ ACC (REGCONT REG))
	ILOOP(COND ((NULL ACC) (GO NEEDP)))
	     (COND ((MEMBER (CAR ACC) (REGCONT PREG)) (GO FOUND)))
	     (SETQ ACC (CDR ACC))
	     (GO ILOOP)
	NEEDP(COND ((NOT (NEEDREG PREG)) (SETQ HOLD PREG)))
	ELOOP(SETQ PREG (NEXTPDLREG PREG))
	     (GO LOOP)
	FOUND(PUTIN (REGCONT REG) PREG)
	     (RETURN NIL)
	NONE (COND ((AND (NOT (NULL HOLD)) (EQ (REGTYPE REG) (Q AC)))
		    (MOVEFROMAC REG HOLD))
		   (T (PUSHREG REG)))
	     (RETURN NIL)))

(DFUNC (FREEAC) (MAKEFREEAC (NTHAC SOMEAC)))

(DFUNC (FINDFREEAC BEST)
       (PROG (AC)
	     (COND ((NULL BEST) (GO LOOK)))
	     (COND ((NOT (NEEDREG BEST)) (RETURN BEST)))
	LOOK (SETQ AC (FIRSTAC))
	LOOP (COND ((LASTAC AC) (RETURN NIL)))
	     (COND ((NOT (NEEDREG AC)) (RETURN AC)))
	     (SETQ AC (NEXTAC AC))
	     (GO LOOP)))

(DFUNC (MAKEFREEAC BEST)
       (PROG (TEM)
	     (COND ((SETQ TEM (FINDFREEAC BEST)) (RETURN TEM)))
	     (COND ((NOT (ISAC BEST)) (COMPERR NOTAC-MAKEFREEAC)))
	     (RETURN BEST)))

(DFUNC (GENCONST OP AC AD IN IB)
       (MCONS (Q C)
	      OP
	      (APPEND (COND ((ZEROP IB) NIL) (T (LIST *AT)))
		      (LIST AC AD IN))))

(DFUNC (GENFUN FUNXPR)
 (PROG (NAME LAMLIS CALL)
       (COND ((ATOM FUNXPR) (RETURN FUNXPR)))
       (COND ((NOT (EQ (CAR FUNXPR) (Q LAMBDA)))
	      (USERERR NOTLAMBDA-GENFUN)))
       (SETQ LAMLIS (CADR FUNXPR))
       (SETQ CALL (CADDR FUNXPR))
       (COND ((AND (ATOM (CAR CALL)) (EQUAL LAMLIS (CDR CALL)))
	      (RETURN (CAR CALL))))
       (SETQ GENFUNS (CONS (SETQ NAME (GENFUNNAME)) GENFUNS))
       (SETQ SUBFUNS (CONS (LIST (Q DEFPROP) NAME FUNXPR (Q EXPR))
			   SUBFUNS))
       (RETURN NAME)))

(DFUNC (GETVAR VAR)
 (PROG (TEM)
       (COND ((NOT (VARIABLEP VAR)) (COMPERR NOTVAR-GETVAR)))
       (COND ((SETQ TEM (ASSOC VAR LOCVARS)) (RETURN (CDR TEM))))
       (COND ((ISSPECVAR VAR) (RETURN VAR)))
       (MAKESPECIAL VAR)
       (RETURN VAR)))

(DFUNC (INITNIL VAR)
       (PUSHREG (LIST (LIST (Q (QUOTE NIL)) NIL T VAR))))

(DFUNC (LAMBDABIND VARS)
 (PROG (VAR AC SPFLG)
       (COND ((AND VARS (ATOM VARS))
	      (USERERR ATOMVARLIST-LAMBDABIND)))
       (SETQ AC (FIRSTAC))
  LOOP (COND ((NULL VARS) (RETURN SPFLG)))
       (SETQ VAR (BINDVAR (CAR VARS)))
       (COND ((SPECIALP VAR) (GO SPECV)))
  ELOOP(PUTIN (LIST VAR) AC)
       (SETQ AC (NEXTAC AC))
       (SETQ VARS (CDR VARS))
       (GO LOOP)
  SPECV(COND ((NOT SPFLG) (SETQ SPFLG T)
			  (OUTINST (Q (JSP 6 SPECBIND)))))
       (OUTINST (LIST 0 (CADR (REGNAME AC)) (LIST (Q SPECIAL) VAR)))
       (GO ELOOP)))

(DFUNC (LOADARGS ARGS)
       (PROG NIL
	LOOP (COND ((NULL ARGS) (RETURN NIL)))
	     (LOADAC (CAAR ARGS) (CDAR ARGS))
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))

(DFUNC (LOADCARCDR ITEM AC)
       (PROG (ARG PATH ORIG)
	     (COND ((NULL AC) (SETQ AC (FREEAC))))
	     (SETQ PATH (GET (CADR ITEM) (Q CARCDR)))
	     (ILOC1 (SETQ ARG (CDDR ITEM)) AC)
	     (DEVALUE ARG)
	     (CPUSH AC)
	     (SETQ ORIG (LOC ARG))
	LOOP (COND ((NULL PATH) (GO RET)))
	     (OUT1 (CAR PATH) AC ORIG)
	     (SETQ PATH (CDR PATH))
	     (SETQ ORIG AC)
	     (GO LOOP)
	RET  (SETREG AC (LIST (CAR ITEM)))
	     (RETURN AC)))

(DFUNC (LOADCOMP XPR AC) (LOADAC (COMPEXPR XPR AC) AC))

(DFUNC (MARKVAL XPR LOC FLAG)
       (PROG (GRES)
	     (SETQ GRES (GENRES))
	     (PUTPROP GRES XPR (Q ORIGIN))
	     (COND (FLAG (PUTONRESULTS GRES)))
	     (COND ((NOT (NULL LOC)) (CLEARREG LOC)
				     (PUTIN (LIST GRES) LOC)))
	     (RETURN GRES)))

(DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))

(DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN))

(DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))

(DFUNC (OUTCJMP FLAG AC TAG)
       (OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE)))
	       (CADR (REGNAME AC))
	       TAG))

(DFUNC (OUTENDTAG X)
       (COND ((USEDTAGP X) (CLEARACS) (RST X) (OUTTAG X))))

(DFUNC (OUTFUNCALL TYPE NUM FUN)
       (OUTINST (LIST TYPE NUM (LIST (Q E) FUN))))

(DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN))

(DFUNC (OUTJMP OP AC ADR)
       (PROG (SAVPDL)
	     (SETQ SAVPDL PDL)
	     (SETQ PDL (COPY PDL))
	     (SAVEACS)
	     (RST ADR)
	     (PUTPROP ADR T (Q USED))
	     (OUTINST (LIST OP AC ADR))
	     (SETQ PDL SAVPDL)))

(DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))

(DFUNC (OUTMOVE AC MEM) (OUT1 (Q MOVE) AC MEM))

(DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM))

(DFUNC (OUTPOP L) (PROG2 (POPSLOT) (OUT1 (Q POP) (Q P) L)))

(DFUNC (OUTPUSH L) (OUT1 (Q PUSH) (Q P) L))

(DFUNC (OUTPUT1 ST)
       (PROG (ADD)
	     (COND ((ATOM ST) (GO PRINT)))
	     (COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
	     (SETQ CODESIZE (ADD1 CODESIZE))
	     (SETQ ADD (CADDR ST))
	     (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
		    (SETQ CONSTSIZE (ADD1 CONSTSIZE))))
	PRINT(PRINTSTAT ST)))

(DFUNC (OUTSTAT ST)
       (PROG NIL
	     (COND ((NULL LASTOUT) (GO SETIT)))
	     (OUTPUT1 (CAR LASTOUT))
	     (MAPC (FUNCTION PRINS) (CDR LASTOUT))
	SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
	     (RETURN NIL)))

(DFUNC (OUTTDZA AC)
       (OUT1 (Q TDZA) (CADR (REGNAME AC)) (CADR (REGNAME AC))))

(DFUNC (PROGBIND VARS)
       (PROG (LVARS VAR SPF)
	LOOP (COND ((NULL VARS) (GO LOCAL)))
	     (SETQ VAR (BINDVAR (CAR VARS)))
	     (COND ((SPECIALP VAR) (GO SPEC)))
	     (SETQ LVARS (CONS VAR LVARS))
	ELOOP(SETQ VARS (CDR VARS))
	     (GO LOOP)
	SPEC (COND ((NULL SPF) (OUTINST (Q (JSP 6 SPECBIND)))
			       (SETQ SPF T)))
	     (OUTINST (LIST 0 0 (LIST (Q SPECIAL) VAR)))
	     (GO ELOOP)
	LOCAL(SETQ LVARS (REVERSE LVARS))
	LLOOP(COND ((NULL LVARS) (RETURN SPF)))
	     (INITNIL (CAR LVARS))
	     (SETQ LVARS (CDR LVARS))
	     (GO LLOOP)))

(DFUNC (PROGTAG PTAG)
       (PROG (LTAG)
	     (SETQ LTAG (EQUIVTAG PTAG))
	     (PUTPROP LTAG T (Q DEFINED))
	     (CLEARSPECIALS)
	     (CLEARACS)
	     (RESTORE PRSSL)
	     (OUTTAG LTAG)))

(DFUNC (PROTECTACS WHICH)
       (COND ((NULL WHICH) (SAVEACS)) (T (PUSHACS (CAR WHICH) T))))

(DFUNC (PROTECTSPECIALS WHICH)
       (PROG (SPECS TEM)
	     (COND ((NULL WHICH) (RETURN (CLEARSPECIALS))))
	     (SETQ SPECS (CADR WHICH))
	LOOP (COND ((NULL SPECS) (RETURN NIL)))
	     (COND ((SETQ TEM (LOCSPECIAL (CAR SPECS))) (CPUSH TEM)))
	     (SETQ SPECS (CDR SPECS))
	     (GO LOOP)))

(DFUNC (PUSHACS MASK FLAG)
       (PROG (AC)
	     (SETQ AC (FIRSTAC))
	LOOP (COND ((OR (ZEROP MASK) (LASTAC AC)) (RETURN NIL)))
	     (COND ((ZEROP (BOOLE 1 1 MASK)) (GO ELOOP)))
	     (CPUSH AC)
	     (COND (FLAG (CLEARREG AC)))
	ELOOP(SETQ MASK (LSH MASK -1))
	     (SETQ AC (NEXTAC AC))
	     (GO LOOP)))

(DFUNC (PUTINAC ITEM AC)
       (PROG (LOC)
	     (SETQ LOC (LOC ITEM))
	     (SETQ AC (COND ((NULL AC) (FREEAC)) (T AC)))
	     (COND ((NOT (ISAC LOC)) (LOADAC ITEM (SETQ LOC AC))))
	     (DEVALUE ITEM)
	     (RETURN LOC)))

(DFUNC (RESTORE OLDPDL)
 (PROG (C V R TEM OLDDEPTH DEPTHDIF)
       (SETQ OLDDEPTH (LENGTH OLDPDL))
       (COND ((GREATERP OLDDEPTH (PDLDEPTH))
	      (PRINTMSG (LIST OLDPDL PDL))
	      (COMPERR SHORTPDL-RESTORE)))
  A1   (SETQ C 0)
  A    (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
	     ((NEEDREG (TOPPDL)) (GO CPP)))
       (SETQ C (ADD1 C))
       (POPSLOT)
       (GO A)
  CPP  (SHRINKPDL C)
  CPP1 (SETQ V OLDPDL)
       (SETQ C 0)
       (SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
  CPP3 (COND ((NULL V) (COMPERR NOROOM-RESTORE)
		       (SETQ V (FINDFREEAC (NTHAC SOMEAC)))
		       (COND ((NULL V) (COMPERR NOAC-RESTORE)))
		       (POPREG V)
		       (GO A1))
	     ((AND (CAR V)
		   (EQ (CAAR V) (CAR R))
		   (NOT	(NEEDREG (SETQ TEM
				       (MINUS (PLUS C DEPTHDIF))))))
	      (GO CPP2)))
       (SETQ C (ADD1 C))
       (SETQ V (CDR V))
       (GO CPP3)
  CPP2 (POPREG TEM)
       (GO A1)))

(DFUNC (RST TAG)
       (PROG (LEVEL)
	     (COND ((NULL TAG) (RETURN NIL)))
	     (COND ((SETQ LEVEL (SEEKPROP TAG (Q LEVEL)))
		    (RESTORE (PROPVAL LEVEL)))
		   ((ASSOCR TAG TAGLIST) (RESTORE PRSSL))
		   (T (COMPERR NOLEVEL-RST)))
	     (RETURN NIL)))

(DFUNC (SAVEACS) (PUSHACS (SUB1 (LSH 1 NACS)) NIL))

(DFUNC (SHRINKPDL C)
       (COND ((NOT (ZEROP C))
	      (OUTINST (LIST (Q SUB) (Q P) (GENCONST 0 0 C C 0))))))

(DFUNC (SIDEEFFECTS FN)
       (COND ((SETQ FN (SEEKPROP FN (Q SIDEEFFECTS))) (PROPVAL FN))
	     (T NIL)))

(DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))

(DFUNC (TESTJUMP ITEM TEST)
 (PROG (AC)
       (COND ((NULL TEST) (RETURN ITEM)))
       (COND ((NOT (ATOM ITEM)) (GO QUOTE)))
       (SETQ AC (PUTINAC ITEM (FREEAC)))
       (OUTCJMP (CAR TEST) AC (CDR TEST))
       (RETURN ITEM)
  QUOTE(COND ((NOT (NULL (CAR TEST)))
	      (COND ((NOT (NULL (CADR ITEM))) (OUTJRST (CDR TEST)))))
	     (T (COND ((NULL (CADR ITEM)) (OUTJRST (CDR TEST))))))
       (RETURN ITEM)))

(DFUNC (TRANSOUT OP AC AD)
 (PROG (TEM IND)
       (COND ((OR (ATOM AD) (NOT (EQ (CAR AD) (Q QUOTE)))) (GO OUT)))
       (COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
	      (SETQ OP (PROPVAL TEM)))
	     (T (SETQ AD (GENCONST 0 0 AD 0 0))))
  OUT  (SETQ IND (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
		       (T (Q (P)))))
       (RETURN (MCONS OP AC AD IND))))

(DFUNC (UNBINDVARS OLDVARS)
       (PROG NIL
	     (COND ((LESSP (LENGTH LOCVARS) (LENGTH OLDVARS))
		    (COMPERR TOOSHORT-UNBINDVARS)))
	LOOP (COND ((EQUAL OLDVARS LOCVARS) (RETURN NIL)))
	     (REMPROP (CDAR LOCVARS) (Q FUNVAR))
	     (SETQ LOCVARS (CDR LOCVARS))
	     (GO LOOP)))

(DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))

(DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))

(BEGINBLOCK INTERNALMACROS)

(DEFPROP INMACRO
 (LAMBDA (DF) (COMPFUNC (CADR DF) (CADDR DF) (Q INMACRO) (Q *MACRO)))
 DEFACTION)

(DEFPROP APPEND
 (LAMBDA (L)
  (COND	((NULL (CDR L)) NIL)
	((NULL (CDDR L)) (CADR L))
	(T (LIST (Q *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
 INMACRO)

(DEFPROP LIST
 (LAMBDA (L)
	 (COND ((NULL (CDR L)) NIL)
	       ((NULL (CDDR L)) (CONS (Q NCONS) (CDR L)))
	       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
 INMACRO)

(DEFPROP NOT (LAMBDA (L) (LIST (Q NULL) (CADR L))) INMACRO)

(ENDBLOCK INTERNALMACROS)

(MAPDEF FTYPE
	 (EXPR CALLSUBR) (SUBR CALLSUBR) (*SUBR CALLSUBR)
	 (*UNDEF CALLSUBR) (LSUBR CALLLSUBR) (*LSUBR CALLLSUBR)
	 (FEXPR CALLFSUBR) (FSUBR CALLFSUBR) (*FSUBR CALLFSUBR)
	 (FUNVAR CALLFUNARGS) (SPECIAL CALLFUNARGS) (BOOL CALLBOOL)
	 (CARCDR CALLCARCDR) (COMMU CALLCOMMU) (MACRO CALLMACRO)
	 (INMACRO CALLINMACRO) (CMP CALLCMP))

(MAPDEF COMMU
	 (CONS XCONS) (EQUAL EQUAL) (*GREAT *LESS) (*LESS *GREAT)
	 (*PLUS *PLUS) (*TIMES *TIMES))

(MAPDEF CMP
	 (ARG CMPARG) (*EVAL CMP*EVAL) (CONS CMPCONS)
	 (ERRSET CMPERRSET) (EVAL CMPEVAL) (FUNCTION CMPFUNCTION)
	 (*FUNCTION CMPFUNCTION) (GO CMPGO) (QUOTE CMPQUOTE)
	 (PROG CMPPROG) (PROG2 CMPPROG2) (PROGN CMPPROGN)
	 (RETURN CMPRETURN) (RPLACA CMPRPLAC) (RPLACD CMPRPLAC)
	 (SETARG CMPSETARG) (SETQ CMPSETQ) (STORE CMPSTORE))

(MAPDEF BOOL (AND BOOLAND) (EQ BOOLEQ) (NULL BOOLNULL) (OR BOOLOR))

(DEFPROP COND T ISCOND)

(DEFPROP ISCOND CMPCOND FTYPE)

(MAPDEF FTYPE (*EXPR CALLSUBR) (*FEXPR CALLFSUBR))

(SETQ CARCDRDEPTH 4)

(PROG (BASE COUNT LIMIT FORM NAME)
      (SETQ BASE 2)
      (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
      (SETQ COUNT (LSH 1 1))
 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
      (SETQ FORM (CDR (EXPLODE COUNT)))
      (SETQ NAME (READLIST (APPEND (QUOTE (C))
				   (SUBST (QUOTE A)
					  0
					  (SUBST (QUOTE D) 1 FORM))
				   (QUOTE (R)))))
      (PUTPROP NAME
	       (SUBST (QUOTE HLRZ@)
		      0
		      (SUBST (QUOTE HRRZ@) 1 (REVERSE FORM)))
	       (QUOTE CARCDR))
      (SETQ COUNT (ADD1 COUNT))
      (GO LOOP))

(MAPDEF SIDEEFFECTS
	 (*APPEND (37 NIL)) (ATOM (1 NIL)) (CONS (3 NIL))
	 (GENSYM (7 NIL)) (GET (3 NIL)) (LAST (3 NIL))
	 (LENGTH (7 NIL)) (MEMBER (37 NIL)) (NCONS (3 NIL))
	 (XCONS (3 NIL)))

(MAPDEF IMMED
	 (CAME CAIE) (CAMN CAIN) (HLLZS@ HLLZS) (HLRZ@ HLRZ)
	 (HRLM@ HRLM) (HRRM@ HRRM) (HRRZ@ HRRZ) (HRRZS@ HRRZS)
	 (MOVE MOVEI))

(SETQ NACS 5)

(SETQ VALUEAC 1)

(SETQ FARGAC 1)

(SETQ GOTABAC 1)

(SETQ ARRAYAC 1)

(SETQ SOMEAC 1)

(SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))

(ENDBLOCK COMPILE)

(BEGINBLOCK STOREMAP)

(DFUNC (ADDR REG)
       (COND ((ISAC REG) (CADR (REGNAME REG)))
	     ((EQ (REGTYPE REG) (Q PDL))
	      (DIFFERENCE (CADR (REGNAME REG)) (PDLDEPTH)))
	     ((EQ (REGTYPE REG) (Q SPECIAL)) (REGNAME REG))
	     ((EQ (REGTYPE REG) (Q QUOTE)) (REGNAME REG))
	     (T (COMPERR WHATISIT-ADDR))))

(DFUNC (CLEARACS) (PUSHACS (SUB1 (LSH 1 NACS)) T))

(DFUNC (CLEARREG REG) (RPLACD (CDDAR REG) NIL))

(DFUNC (CLEARRESULTS)
       (PROG (RES)
	     (SETQ RES RESULTS)
	LOOP (COND ((NULL RES) (RETURN NIL)))
	     (COND ((ASSOC (GET (CAR RES) (Q ORIG)) LOCVARS)
		    (CPUSH (LOC (CAR RES)))))
	     (SETQ RES (CDR RES))
	     (GO LOOP)))

(DFUNC (CLEARSPECIALS)
       (PROG (SPEC)
	     (SETQ SPEC (FIRSTSPECIAL))
	LOOP (COND ((LASTSPECIAL SPEC) (RETURN NIL)))
	     (CPUSH SPEC)
	     (SETQ SPEC (NEXTSPECIAL SPEC))
	     (GO LOOP)))

(DFUNC (COPYREG SL1 SL2) (RPLACD (CDDAR SL1) (CDDDAR SL2)))

(DFUNC (DEVALUE DATA)
       (PROG (TEM)
	     (SETQ TEM (GETPROP (Q RESULTS) (Q VALUE)))
	LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
	     (COND ((EQUAL (CADR TEM) DATA) (RPLACD TEM (CDDR TEM)))
		   (T (SETQ TEM (CDR TEM))))
	     (GO LOOP)))

(DFUNC (EXPUNGE VAR)
       (PROGN (EXPUNGEACS VAR)
	      (EXPUNGEPDL VAR)
	      (EXPUNGESPECIALS VAR)
	      (EXPUNGEQUOTES VAR)))

(DFUNC (EXPUNGEACS VAR)
       (PROG (ACC)
	     (SETQ ACC (FIRSTAC))
	LOOP (COND ((LASTAC ACC) (RETURN NIL)))
	     (TAKEOUT VAR ACC)
	     (SETQ ACC (NEXTAC ACC))
	     (GO LOOP)))

(DFUNC (EXPUNGEPDL VAR)
       (PROG (PDLREG)
	     (SETQ PDLREG (TOPPDL))
	LOOP (COND ((BOTTOMPDL PDLREG) (RETURN NIL)))
	     (TAKEOUT VAR PDLREG)
	     (SETQ PDLREG (NEXTPDLREG PDLREG))
	     (GO LOOP)))

(DFUNC (EXPUNGEQUOTES VAR)
       (PROG (QREG)
	     (SETQ QREG (FIRSTQUOTE))
	LOOP (COND ((LASTQUOTE QREG) (RETURN NIL)))
	     (TAKEOUT VAR QREG)
	     (SETQ QREG (NEXTQUOTE QREG))
	     (GO LOOP)))

(DFUNC (EXPUNGESPECIALS VAR)
       (PROG (SPEC)
	     (SETQ SPEC (FIRSTSPECIAL))
	LOOP (COND ((LASTSPECIAL SPEC) (RETURN NIL)))
	     (TAKEOUT VAR SPEC)
	     (SETQ SPEC (NEXTSPECIAL SPEC))
	     (GO LOOP)))

(DFUNC (FIRSTAC) ACS)

(DFUNC (FIRSTQUOTE) QUOTES)

(DFUNC (FIRSTSPECIAL) SPECIALS)

(DFUNC (INITACS NUM)
       (PROG (ACCS)
	LOOP (COND ((ZEROP NUM) (RETURN ACCS)))
	     (SETQ ACCS (CONS (LIST (LIST (Q AC) NUM) NIL NIL) ACCS))
	     (SETQ NUM (SUB1 NUM))
	     (GO LOOP)))

(DFUNC (INREG ITEM REG) (MEMBER ITEM (REGCONT REG)))

(DFUNC (ISAC REG) (EQ (REGTYPE REG) (Q AC)))

(DFUNC (ISLOCVAR ITEM) (ASSOCR ITEM LOCVARS))

(DFUNC (ISWAITING ITEM) (MEMBER ITEM RESULTS))

(DFUNC (KNOWLOC VAR)
       (COND ((LOCAC VAR)) ((LOCPDL VAR)) ((LOCSPECIAL VAR))))

(DFUNC (LASTAC AC) (NULL AC))

(DFUNC (BOTTOMPDL REG) (NULL REG))

(DFUNC (LASTQUOTE QT) (NULL QT))

(DFUNC (LASTSPECIAL SPEC) (NULL SPEC))

(DFUNC (LOADAC ITEM AC)
       (COND ((OR (NULL ITEM) (NULL AC)) NIL)
	     (T (MOVETOAC AC (LOC ITEM)) (DEVALUE ITEM))))

(DFUNC (LOC ITEM)
       (PROG (SL)
	     (COND ((SETQ SL (LOCAC ITEM)) (RETURN SL)))
	     (COND ((EQ (CAR ITEM) (Q QUOTE))
		    (RETURN (LIST (LIST ITEM NIL T ITEM)))))
	     (COND ((SETQ SL (LOCPDL ITEM)) (RETURN SL)))
	     (COND ((SETQ SL (LOCSPECIAL ITEM)) (RETURN SL)))
	     (PRINTMSG ITEM)
	     (COMPERR LOSTVAR-LOC)))

(DFUNC (LOCAC ITEM)
       (PROG (AC)
	     (SETQ AC (FIRSTAC))
	LOOP (COND ((LASTAC AC) (RETURN NIL)))
	     (COND ((INREG ITEM AC) (RETURN AC)))
	     (SETQ AC (NEXTAC AC))
	     (GO LOOP)))

(DFUNC (LOCPDL ITEM)
       (PROG (PS)
	     (SETQ PS (TOPPDL))
	LOOP (COND ((BOTTOMPDL PS) (RETURN NIL)))
	     (COND ((INREG ITEM PS) (RETURN PS)))
	     (SETQ PS (NEXTPDLREG PS))
	     (GO LOOP)))

(DFUNC (LOCSPECIAL ITEM)
       (PROG (SP)
	     (SETQ SP (FIRSTSPECIAL))
	LOOP (COND ((LASTSPECIAL SP) (RETURN NIL)))
	     (COND ((INREG ITEM SP) (RETURN SP)))
	     (SETQ SP (NEXTSPECIAL SP))
	     (GO LOOP)))

(DFUNC (MAKESPECIAL VAR)
       (COND ((ISSPECVAR VAR) VAR)
	     (T	(SETQ SPECIALS (CONS (LIST (LIST (Q SPECIAL) VAR)
					   NIL
					   NIL
					   VAR)
				     SPECIALS))
		(SETQ SPECVARS (CONS VAR SPECVARS))
		(COND ((NOT (SPECIALP VAR))
		       (SETQ UNDECVARS (CONS VAR UNDECVARS))
		       (DECSPECIAL VAR))))))

(DFUNC (MOVETOAC AC LOC)
 (PROGN	(COND ((WRITELOCKED AC) (COMPERR WRITELOCKEDAC-MOVETOAC)))
	(CPUSH AC)
	(COPYREG AC LOC)
	(COND ((EQ (REGTYPE LOC) (Q AC))
	       (COND ((NOT (EQ (REGNAME AC) (REGNAME LOC)))
		      (OUTMOVE (CADR (REGNAME AC))
			       (CADR (REGNAME LOC))))))
	      ((EQ (REGTYPE LOC) (Q PDL))
	       (OUTMOVE	(CADR (REGNAME AC))
			(DIFFERENCE (CADR (REGNAME LOC))
				    (PDLDEPTH))))
	      ((EQ (REGTYPE LOC) (Q SPECIAL))
	       (OUTMOVE (CADR (REGNAME AC)) (REGNAME LOC)))
	      ((EQ (REGTYPE LOC) (Q QUOTE))
	       (OUTMOVE (CADR (REGNAME AC)) (REGNAME LOC)))
	      (T (COMPERR WHATISIT-MOVETOAC)))))

(DFUNC (MOVEFROMAC AC LOC)
 (PROGN	(COND ((WRITELOCKED LOC) (COMPERR WRITELOCKED-MOVEFROMAC)))
	(CPUSH LOC)
	(COPYREG LOC AC)
	(COND ((EQ (REGTYPE LOC) (Q AC))
	       (COND ((NOT (EQ (REGNAME AC) (REGNAME LOC)))
		      (OUTMOVEM	(CADR (REGNAME AC))
				(CADR (REGNAME LOC))))))
	      ((EQ (REGTYPE LOC) (Q PDL))
	       (OUTMOVEM (CADR (REGNAME AC))
			 (*DIF (CADR (REGNAME LOC)) (PDLDEPTH))))
	      ((EQ (REGTYPE LOC) (Q SPECIAL))
	       (OUTMOVEM (CADR (REGNAME AC)) (REGNAME LOC))))))

(DFUNC (NEEDITEM ITEM) (OR (ISWAITING ITEM) (ISLOCVAR ITEM)))

(DFUNC (NEEDREG REG)
       (PROG (SC)
	     (COND ((WRITELOCKED REG) (RETURN T)))
	     (SETQ SC (REGCONT REG))
	LOOP (COND ((NULL SC) (RETURN NIL)))
	     (COND ((NEEDITEM (CAR SC)) (RETURN T)))
	     (SETQ SC (CDR SC))
	     (GO LOOP)))

(DFUNC (NEXTAC AC) (CDR AC))

(DFUNC (NEXTPDLREG PS) (CDR PS))

(DFUNC (NEXTQUOTE SL) (CDR SL))

(DFUNC (NEXTSPECIAL SPEC) (CDR SPEC))

(DFUNC (NTHAC NUM) (NTHCDR (SUB1 NUM) (FIRSTAC)))

(DFUNC (POPREG REG)
       (PROGN (COPYREG REG (TOPPDL)) (POPSLOT) (OUTPOP (ADDR REG))))

(DFUNC (PUSHREG REG)
 (PROGN (PUSHSLOT) (COPYREG (TOPPDL) REG) (OUTPUSH (ADDR REG))))

(DFUNC (PUTONRESULTS ITEM) (SETQ RESULTS (CONS ITEM RESULTS)))

(DFUNC (PUTIN ITEMS REG)
       (PROG NIL
	LOOP (COND ((NULL ITEMS) (RETURN NIL)))
	     (COND ((MEMBER (CAR ITEMS) (REGCONT REG)) (GO ELOOP)))
	     (RPLACA REG
		     (MCONS (CAAR REG)
			    (CADAR REG)
			    (CADDAR REG)
			    (CAR ITEMS)
			    (CDDDAR REG)))
	ELOOP(SETQ ITEMS (CDR ITEMS))
	     (GO LOOP)))

(DFUNC (READLOCK REG)
       (RPLACA REG (MCONS (CAAR REG) T (CADDAR REG) (CDDDAR REG))))

(DFUNC (READLOCKED REG) (CADAR REG))

(DFUNC (READUNLOCK REG)
       (RPLACA REG (MCONS (CAAR REG) NIL (CADDAR REG) (CDDDAR REG))))

(DFUNC (REGCONT REG) (CDDDAR REG))

(DFUNC (REGNAME REG) (CAAR REG))

(DFUNC (POPSLOT) (SETQ PDL (CDR PDL)))

(DFUNC (PUSHSLOT)
 (SETQ PDL (CONS (LIST (LIST (Q PDL) (ADD1 (PDLDEPTH))) NIL NIL)
		 PDL)))

(DFUNC (REGTYPE REG) (CAAAR REG))

(DFUNC (TAKEOUT VAR REG)
 (PROG (CONT)
       (SETQ CONT (CDDAR REG))
  LOOP (COND ((NULL (CDR CONT)) (RETURN NIL)))
       (COND ((EQUAL VAR (CADR CONT)) (RPLACD CONT (CDDR CONT))))
       (SETQ CONT (CDR CONT))
       (GO LOOP)))

(DFUNC (TOPPDL) PDL)

(DFUNC (WRITELOCK REG)
       (RPLACA REG (MCONS (CAAR REG) (CADAR REG) T (CDDDAR REG))))

(DFUNC (WRITELOCKED REG) (CADDAR REG))

(DFUNC (WRITEUNLOCK REG)
       (RPLACA REG (MCONS (CAAR REG) (CADAR REG) NIL (CDDDAR REG))))

(DFUNC (WRITEUNLOCKACS NUM)
       (PROG (ACCS)
	     (SETQ ACCS (FIRSTAC))
	LOOP (COND ((OR (LASTAC ACCS) (ZEROP NUM)) (RETURN NIL)))
	     (WRITEUNLOCK ACCS)
	     (SETQ ACCS (NEXTAC ACCS))
	     (SETQ NUM (SUB1 NUM))
	     (GO LOOP)))

(ENDBLOCK STOREMAP)

(BEGINBLOCK SOURECSTRUCTURES)

(DFUNC (ISLOCVAR VAR) (ASSOCR VAR LOCVARS))

(DFUNC (ISRESULT ITEM) (MEMQ ITEM RESULTS))

(DFUNC (ISSPECVAR VAR) (MEMQ VAR SPECVARS))

(DFUNC (ISSPECVAR VAR) (ASSOC (LIST (Q SPECIAL) VAR) SPECIALS))

(ENDBLOCK SOURCESTRUCTURES)

(BEGINBLOCK DEBUG)

(DEFPROP COMPERR
	 (LAMBDA (L) (COMPBREAK (Q (*COMPILER ERROR*)) L))
	 FEXPR)

(DEFPROP USERERR (LAMBDA (L) (COMPBREAK (Q (*USER ERROR*)) L)) FEXPR)

(DFUNC (COMPBREAK TYPE MESSAGE)
       (PROG NIL
	     (INC NIL T)
	     (OUTC NIL T)
	     (CARRET)
	     (LINEF)
	     (PRINL (APPEND TYPE MESSAGE))
	LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED)))
		    (RETURN (Q DONE))))
	     (GO LOOP)))

(DFUNC (EVALREAD)
       (PROG (EX)
	     (CARRET)
	     (SETQ EX (READ))
	     (PRINC *SP)
	     (RETURN (PRINC (EVAL EX)))))

(DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))

(SETQ SHOWNAMES NIL)

(SETQ TRACELIST NIL)

(ENDBLOCK DEBUG)

(BEGINBLOCK PATCH)

(DFUNC (ILOC ITEM AC) (LOC ITEM))

(REMPROP (QUOTE EQ) (QUOTE BOOL))

(REMPROP (QUOTE CARCDR) (QUOTE FTYPE))

(REMPROP (QUOTE *EVAL) (QUOTE CMP))

(REMPROP (QUOTE RPLACA) (QUOTE CMP))

(REMPROP (QUOTE RPLACD) (QUOTE CMP))

(SETQ SHOWNAMES T)

(ENDBLOCK PATCH)

(BEGINBLOCK IO)

(DFUNC (CARRET) (COND ((NOT (EQ (CHRCT) (LINELENGTH NIL))) (LINEF))))

(DFUNC (DEVP L)
       (OR (AND (ATOM L) (EQ (CAR (LAST L)) *COLON))
	   (AND (NOT (ATOM L)) (NOT (ATOM (CDR L))))))

(DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))

(DFUNC (PRINS X) (PROG2 (PRIN1 X) (PRINC *SP)))

(DFUNC (PRINTLAP CODE) (MAPC (FUNCTION PRINTSTAT) CODE))

(DFUNC (PRINTSTAT STAT)
 (PROG NIL
       (COND ((GREATERP (DIFFERENCE (LINELENGTH NIL) (CHRCT)) 7)
	      (LINEF)))
       (COND ((NULL STAT) (GO WORD))
	     ((ATOM STAT) (GO TAG))
	     ((EQ (CAR STAT) (QUOTE LAP)) (GO TAG)))
  WORD (PRINC *TB)
       (PRINS STAT)
       (RETURN NIL)
  TAG  (CARRET)
       (PRINS STAT)
       (RETURN NIL)))

(DFUNC (READLAP CALL)
       (PROG (STAT CODE)
	     (SETQ CODE (LIST CALL))
	READ (SETQ STAT (ERRSET (READ)))
	     (COND ((ATOM STAT) (USERERR READERR-READLAP)))
	     (SETQ CODE (CONS (CAR STAT) CODE))
	     (COND ((NULL (CAR STAT)) (RETURN (REVERSE CODE))))
	     (GO READ)))

(MAPCAR	(FUNCTION (LAMBDA (PAIR)
			  (PROG2 (SET (CAR PAIR)
				      (INTERN (ASCII (CADR PAIR))))
				 (CAR PAIR))))
	(QUOTE ((*SP 40) (*TB 11)
			 (*CR 15)
			 (*LF 12)
			 (*VT 13)
			 (*FF 14)
			 (*FF 14)
			 (*CO 54)
			 (*PT 56)
			 (*LP 50)
			 (*RP 51)
			 (*SL 57)
			 (*AM 33)
			 (*AT 100)
			 (*RO 177)
			 (*COLON 72))))

(ENDBLOCK IO)

(BEGINBLOCK GENERAL)

(DFUNC (ASSOCR X Y)
       (PROG NIL
	LOOP (COND ((NULL Y) (RETURN NIL))
		   ((EQ X (CDAR Y)) (RETURN (CAR Y))))
	     (SETQ Y (CDR Y))
	     (GO LOOP)))

(DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMQ XPR (QUOTE (T NIL)))))

(DFUNC (COPY EX) (SUBST 0 0 EX))

(DFUNC (DECSPECIAL VAR) (PROGN (PUTPROP VAR T (Q SPECIAL)) VAR))

(DFUNC (DECUNSPECIAL VAR)
       (COND ((REMPROP VAR (Q SPECIAL)) VAR) (T NIL)))

(DFUNC (DEINITSYM SYM) (DELETEPROP SYM (Q SYMNO)))

(DFUNC (GETGET ATOM PROP)
       (PROG (TEM PTAB)
	     (SETQ PTAB (FIRSTPROP ATOM))
	LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
	     (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
		    (RETURN TEM)))
	     (SETQ PTAB (NEXTPROP PTAB))
	     (GO LOOP)))

(DFUNC (INITSYM NAME) (INITPROP NAME (Q SYMNO) 0))

(DFUNC (MAKESYM IDENT NUMBER)
 (PROG (*NOPOINT)
       (SETQ *NOPOINT T)
       (RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))

(DFUNC (NEXTSYM NAME)
       (PROG (NUM)
	     (SETQ NUM (GETPROP NAME (Q SYMNO)))
	     (SETPROP NAME (Q SYMNO) (ADD1 NUM))
	     (RETURN (MAKESYM NAME NUM))))

(DFUNC (NTHCDR NUM EXP)
       (PROG NIL
	LOOP (COND ((ZEROP NUM) (RETURN EXP)))
	     (SETQ EXP (CDR EXP))
	     (SETQ NUM (SUB1 NUM))
	     (GO LOOP)))

(DEFPROP PROGN (LAMBDA L (ARG L)) EXPR)

(DFUNC (TOPCOPY SXP) (APPEND SXP NIL))

(DFUNC (TOPCOPY SXP) (COPY SXP))

(BEGINBLOCK PROPTABLE)

(DFUNC (DELETEPROP IDENT PROPNAM)
       (PROG (TEM)
	     (SETQ TEM IDENT)
	LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
	     (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
					    (RETURN T)))
	     (SETQ TEM (CDDR TEM))
	     (GO LOOP)))

(DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))

(DFUNC (INITPROP IDENT PROPNAM PROPVAL)
       (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))

(DFUNC (SEEKPROP IDENT PROPNAM)
       (PROG (TEM)
	     (SETQ TEM (GETL IDENT (LIST PROPNAM)))
	     (COND ((NULL TEM) (RETURN NIL)))
	     (RETURN TEM)))

(DFUNC (SETPROP IDENT PROPNAM PROPVAL)
       (PUTPROP IDENT PROPVAL PROPNAM))

(ENDBLOCK PROPTABLE)

(ENDBLOCK GENERAL)

(ENDBLOCK COMPILER)